Shareware Grab Bag/Shareware Grab Bag.iso/011/dos2io.arc/DOS2IO-2.INC

Text File | 1980-01-01 | 16.1 KB | 638 lines

(*
                          Dos2io-2.inc



    Dedicated to the public domain.

        -- Cole Brecheen
           17 August 1985
*)

{$V-,U-,C-,R-}
CONST
  SegSize = 6.5536E+4;

TYPE
  BitRange = 0..15;
  BitSet = SET OF BitRange;


PROCEDURE IntegerToBitSet( TheInteger : INTEGER;
                   VAR TheSet : BitSet );
VAR
  tmp: RECORD
     CASE BOOLEAN of
       true: ( IntForm : INTEGER );
       false:( SetForm : BitSet );
       END;
BEGIN {IntegerToBitSet}
  tmp.IntForm := TheInteger;
  TheSet := tmp.SetForm;
END;  {IntegerToBitSet}


PROCEDURE BitSetToInteger( TheSet : BitSet;
                   VAR TheInteger : INTEGER );
VAR
  tmp: RECORD
     CASE BOOLEAN of
       true: ( IntForm : INTEGER );
       false:( SetForm : BitSet );
       END;
BEGIN {BitSetToInteger}
  tmp.SetForm := TheSet;
  TheInteger := tmp.IntForm;
END;  {BitSetToInteger}



FUNCTION WordToReal( TheWord : INTEGER ): REAL;
var
  storage: real;
BEGIN  {WordToReal}
  IF (TheWord > maxint) OR (TheWord < 0) THEN
    BEGIN
      storage := ord(TheWord);
      WordToReal := storage + maxint + maxint + 2;
    END
  ELSE WordToReal := ORD( TheWord );
END;  {WordToReal}


FUNCTION RealToWord( TheReal : REAL ): INTEGER;
BEGIN  {RealToWord}
  IF (TheReal < 0) or (TheReal >= segsize)
    THEN abort('Real out of word range:  '+RealStr(TheReal,0,0));
  if TheReal >= (segsize - 1) then
    RealToWord := -1
  else
    IF TheReal > maxint THEN
      RealToWord := maxint + round(TheReal - maxint)
    ELSE RealToWord := round(TheReal);
END;  {RealToWord}




PROCEDURE RealToSegmented( TheReal: REAL;
                   VAR TheSeg, TheOfs: INTEGER );
BEGIN {RealToSegmented}
  IF TheReal > SegSize THEN
    TheSeg := trunc(TheReal / SegSize)
  ELSE
    TheSeg := 0;
  TheOfs := RealToWord( TheReal - (TheSeg * SegSize) );
END; {RealToSegmented}


FUNCTION SegmentedToReal( TheSeg, TheOfs: INTEGER ): REAL;
VAR
  tmp: REAL;
BEGIN {SegmentedToReal}
  tmp := WordToReal( TheSeg ) * SegSize;
  SegmentedToReal := WordToReal( TheOfs ) + tmp;
END; {SegmentedToReal}




PROCEDURE lowerch( VAR TheCh : CHAR );
    {Converts TheCh to lower case.}
BEGIN
  IF TheCh in ['A'..'Z']
    THEN TheCh := chr( ord(TheCh) + 32 );
END; {lowerch}



FUNCTION  BlockRead ( FileHandle : INTEGER;
               VAR buffer : buftype;
               BlockNumber : INTEGER ): ErrorMessage;
VAR
  rgstr : RegPack;
  BlksInSeg : integer;
BEGIN {BlockRead}
  BlockRead := NoError;
  BlksInSeg := trunc( SegSize / BufSize );
  WITH rgstr DO BEGIN
    a.h := $42;  {command to move file read/write pointer}
    a.l := 0;
    {moves pointer to offset bytes from beginnning of file}
    b.x := FileHandle;
    c.x := BlockNumber DIV BlksInSeg;
    d.x := (BlockNumber - (c.x * BlksInSeg)) * BufSize;
    msdos( rgstr );
    IF FlaggedError( flags )
      THEN BEGIN {writeln('Blockread error');  } {diag}
          PrintMessage( MessageType( a.x ) );
          END;

    b.x := FileHandle;
    c.x := BufSize;
    a.h := $3F;  {Read from a file or device.}
    d.x := ofs( buffer );
    ds := seg( buffer );
    msdos( rgstr );
    IF FlaggedError( flags )
      THEN BlockRead := MessageType( a.x )
      ELSE
    BEGIN
      IF a.x < c.x
        THEN
          IF a.x = 0
        THEN BlockRead := EndOfFile
        ELSE BlockRead := PartialRead
        ELSE BlockRead := NoError;
    END
  END; {WITH rgstr}
END;  {BlockRead}



FUNCTION BlockWrite( FileHandle : INTEGER;
             VAR buffer : buftype;
             BlockNumber : INTEGER ): ErrorMessage;
VAR
  rgstr : RegPack;
  BlksInSeg : integer;
BEGIN {BlockWrite}
  BlockWrite := NoError;
  BlksInSeg := trunc( SegSize / BufSize );
  WITH rgstr DO BEGIN
    a.h := $42;  {command to move file read/write pointer}
    a.l := 0;
    {moves pointer to offset bytes from beginnning of file}
    b.x := FileHandle;
    c.x := BlockNumber DIV BlksInSeg;
    d.x := (BlockNumber - (c.x * BlksInSeg))* BufSize;
    msdos( rgstr );
    IF FlaggedError( flags )
      THEN PrintMessage( MessageType( a.x ) );

    b.x := FileHandle;
    c.x := BufSize;
    a.h := $40; {Write to a file or device.}
    d.x := ofs( buffer );
    ds := seg( buffer );
    msdos( rgstr );
    IF a.x < c.x  {if fewer than c.x bytes were actually written}
      THEN abort( 'No room to write.' );
    IF FlaggedError( flags )
      THEN BlockWrite := MessageType( a.x );
  END; {WITH rgstr}
END; {BlockWrite}



PROCEDURE GetProgramParameter( VAR ParamStr : dos2str80 );
VAR
  TmpStr : string[80] absolute cseg:$0080;
BEGIN {GetProgramParameter}
  IF length( TmpStr ) > 1 THEN
    ParamStr := copy( TmpStr, 2, length(TmpStr) - 1 )
    {We start at 2 and copy length - 1 because the first
    character in the parameter will always be a space.}
  ELSE
    ParamStr := null;
END;  {GetProgramParameter}




FUNCTION CloseHandle ( FileHandle : INTEGER ): ErrorMessage;
LABEL EndProcedure;
VAR
  TmpPtr : BufferPtr;
  rgstr : RegPack;
BEGIN {CloseHandle}
  CloseHandle := NoError;
  WITH rgstr DO BEGIN
    a.h := $3E;  {close a FileHandle}
    b.x := FileHandle;
    msdos( rgstr );
    IF FlaggedError( flags )
      THEN CloseHandle := MessageType( a.x );
  END; {WITH rgstr}

  CheckInitialization;
    {From here down we are releasing any memory that ReadStr
    may have allocated to FileHandle for buffering purposes.}

  IF BufLstBase = nil
    THEN GOTO EndProcedure;
  TmpPtr := BufLstBase;
  IF (TmpPtr^.next = NIL) AND (TmpPtr^.handle = FileHandle) THEN
    BufLstBase := NIL                         {added 6/6/85}
  ELSE  WHILE (TmpPtr^.next <> nil)
    and
    (TmpPtr^.handle <> FileHandle) DO TmpPtr := TmpPtr^.next;
  IF TmpPtr^.handle = FileHandle
    THEN
      BEGIN
    IF TmpPtr^.prev <> NIL THEN TmpPtr^.prev^.next := TmpPtr^.next;
    IF TmpPtr^.next <> NIL THEN TmpPtr^.next^.prev := TmpPtr^.prev;
    dispose( TmpPtr );
      END;
  EndProcedure:
END;  {CloseHandle}



FUNCTION FileLength( FileHandle : INTEGER ): REAL;
    {Returns the number of bytes in the file identified by
    FileHandle.}
VAR
  rgstr : RegPack;
  tmp : REAL;
  OldSeg, OldOfs : INTEGER;
BEGIN {FileLength}
  WITH rgstr DO BEGIN
    a.l := 1;  {move pointer to current location plus offset}
    a.h := $42;
    b.x := FileHandle;
    c.x := 0;  {most significant part of the offset}
    d.x := 0;  {least significant part of the offset}
    msdos( rgstr );
    IF FlaggedError( flags )
      THEN BEGIN { writeln('filelength error'); } {diag}
        PrintMessage( MessageType( a.x ) );
      END;
    OldSeg := d.x;
    OldOfs := a.x;
    {We save these values so we can restore the pointer to
    its original location.}

    a.l := 2;  {move pointer to end of file plus offset}
    a.h := $42;
    b.x := FileHandle;
    c.x := 0;  {most significant part of the offset}
    d.x := 0;  {least significant part of the offset}
    msdos( rgstr );
    IF FlaggedError( flags )
      THEN BEGIN { writeln('filelength error'); } {diag}
        PrintMessage( MessageType( a.x ) );
      END;
    FileLength := SegmentedToReal( d.x, a.x );

    a.l := 0;
    {move pointer to offset bytes from beginning of file}
    a.h := $42;
    b.x := FileHandle;
    c.x := OldSeg;  {most significant part of the offset}
    d.x := OldOfs;  {least significant part of the offset}
    msdos( rgstr );
      {Restores pointer to its original location.}
    IF FlaggedError( flags )
      THEN BEGIN { writeln('filelength error'); } {diag}
        PrintMessage( MessageType( a.x ) );
      END;
  END; {WITH rgstr}
END; {FileLength}



FUNCTION  OpenFile ( VAR FileHandle : INTEGER;
                fname : dos2str80): ErrorMessage;
VAR
  rgstr : RegPack;
BEGIN  {OpenFile}
  FileHandle := 0;
  OpenFile := NoError;
  MakeAsciiZ( fname );
  WITH rgstr DO BEGIN
    a.h := $3D;   {open a file}
    A.L := 2;     {for reading and writing}
    b.x := 0;
    c.x := 0;
    d.x := ofs( fname );
    ds := seg( fname );
    msdos( rgstr );
    IF FlaggedError( flags )
      THEN OpenFile := MessageType( a.x )
      ELSE FileHandle := a.x;
  END; {WITH rgstr}
END;  {OpenFile}



FUNCTION  CreateFile ( VAR FileHandle : INTEGER;
             fname : dos2str80): ErrorMessage;
VAR
  rgstr : RegPack;
BEGIN  {CreateFile}
  FileHandle := 0;
  CreateFile := NoError;
  MakeAsciiZ( fname );

  WITH rgstr DO BEGIN
    a.h := $3C;   {create a file}
    A.L := 0;
    b.x := 0;
    c.x := 0;  {attribute of the file; 0 makes it normal}
    d.x := ofs( fname );
    ds := seg( fname );
    msdos( rgstr );
    IF FlaggedError( flags )
      THEN CreateFile := MessageType( a.x )
      ELSE FileHandle := a.x;
  END; {WITH rgstr}
END;  {CreateFile}



FUNCTION EndFile( FileHandle : INTEGER ): BOOLEAN;
VAR
  rgstr : RegPack;
  OldSeg, OldOfs : INTEGER;
BEGIN {EndFile}
  WITH rgstr DO BEGIN
    a.l := 1;  {move pointer to current location plus offset}
    a.h := $42;
    b.x := FileHandle;
    c.x := 0;  {most significant part of the offset}
    d.x := 0;  {least significant part of the offset}
    msdos( rgstr );
    OldSeg := d.x;
    OldOfs := a.x;

    a.l := 2;  {move pointer to end of file plus offset}
    a.h := $42;
    b.x := FileHandle;
    c.x := 0;  {most significant part of the offset}
    d.x := 0;  {least significant part of the offset}
    msdos( rgstr );
    EndFile := (d.x <= OldSeg) and (a.x <= OldOfs);

    a.l := 0;
    {move pointer to offset bytes from beginning of file}
    a.h := $42;
    b.x := FileHandle;
    c.x := OldSeg;  {most significant part of the offset}
    d.x := OldOfs;  {least significant part of the offset}
    msdos( rgstr );
      {Restores pointer to its original location.}
  END; {WITH rgstr}
END; {EndFile}



FUNCTION RenameFile( OldFileName,
             NewFileName :  Dos2str80 ): ErrorMessage;
VAR
  rgstr : RegPack;
BEGIN {RenameFile}
  RenameFile := NoError;
  IF pos( ':', NewFileName ) = 2
    THEN delete( NewFileName, 1, 2 );
  IF pos( ':', OldFileName ) = 2
    THEN insert( copy(OldFileName, 1, 2), NewFileName, 1 );
  MakeAsciiZ( OldFileName );
  MakeAsciiZ( NewFileName );
  WITH rgstr DO BEGIN
    ds := seg( OldFileName );
    d.x := ofs( OldFileName );
    es := seg( NewFileName );
    di := ofs( NewFileName );
    a.h := $56; {Rename a file.}
    msdos( rgstr );
    IF FlaggedError( flags )
      THEN RenameFile := MessageType( a.x );
  END; {WITH rgstr}
END; {RenameFile}



FUNCTION DeleteFile( FileName : Dos2str80 ): ErrorMessage;
VAR
  rgstr : RegPack;
BEGIN {DeleteFile}
  DeleteFile := NoError;
  MakeAsciiZ( FileName );
  WITH rgstr DO BEGIN
    ds := seg( FileName );
    d.x := ofs( FileName );
    a.h := $41; {Delete a file from a specified directory.}
    msdos( rgstr );
    IF FlaggedError( flags )
      THEN DeleteFile := MessageType ( a.x );
  END; {WITH rgstr}
END; {DeleteFile}


TYPE
  FileMode = (NormalFile, ReadOnlyFile, HiddenFile, SystemFile);
  ModeSet = set of FileMode;

FUNCTION SetFileMode( FileName: dos2str80;
              TheSet: ModeSet ): ErrorMessage;
VAR
  TmpMode : FileMode;
  rgstr : RegPack;
  TmpSet : BitSet;
BEGIN {SetFileMode}
  SetFileMode := NoError;
  MakeAsciiZ( FileName );
  WITH rgstr DO BEGIN
    a.h := $43; {Change file mode command (CHMOD).}
    a.l := 1;
    {Indicates that we want to change the mode rather than
    find out what it presently is.}
    ds := seg( FileName );
    d.x := ofs( FileName );

    TmpSet := [];
    TmpMode := NormalFile;
    WHILE TheSet <> [] DO BEGIN
      IF TmpMode in TheSet THEN
    CASE TmpMode of
      NormalFile:
        BEGIN
          TmpSet := [];
          TheSet := [];
        END;
      ReadOnlyFile: TmpSet := TmpSet + [0];
      HiddenFile: TmpSet := TmpSet + [1];
      SystemFile: TmpSet := TmpSet + [2];
    END; {case}
      IF TheSet <> [] THEN
    TheSet := TheSet - [TmpMode];
      TmpMode := succ( TmpMode );
    END; {while}

    BitSetToInteger( TmpSet, c.x );
    msdos( rgstr );
    IF FlaggedError( flags ) THEN
      SetFileMode := MessageType( a.x );
  END; {WITH rgstr}
END; {SetFileMode}


FUNCTION GetFileMode( FileName: dos2str80;
              VAR TheSet: ModeSet ): ErrorMessage;
VAR
  rgstr : RegPack;
  TmpSet : BitSet;
BEGIN {GetFileMode}
  MakeAsciiZ( FileName );
  GetFileMode := NoError;
  TheSet := [];
  WITH rgstr DO BEGIN
    a.h := $43; {Change file mode command (CHMOD).}
    a.l := 0; {Indicates that we want the file's present mode.}
    ds := seg( FileName );
    d.x := ofs( FileName );
    msdos( rgstr );
    IF FlaggedError( flags ) THEN
      GetFileMode := MessageType( a.x )
    ELSE
      BEGIN
    IntegerToBitSet( c.x, TmpSet );
    TheSet := [NormalFile];
    IF 2 in TmpSet THEN
      TheSet := TheSet + [SystemFile];
    IF 1 in TmpSet THEN
      TheSet := TheSet + [HiddenFile];
    IF 0 in TmpSet THEN
      TheSet := TheSet + [ReadOnlyFile];
    IF TheSet <> [NormalFile] THEN
    {i.e., if something's been added}
      TheSet := TheSet - [NormalFile];
      END;
  END; {WITH rgstr}
END; {GetFileMode}



FUNCTION DefaultDrive: CHAR;
    {Returns the current default drive as a lower case
    letter.}
VAR
  rgstr : RegPack;
BEGIN  {DefaultDrive}
  rgstr.a.h := $19;  {DOS "current disk" function number}
  msdos( rgstr );
  DefaultDrive := CHR( ORD(rgstr.a.l) + ORD( 'a' ) );
END;  {DefaultDrive}



PROCEDURE SetDefaultDrive( DriveLetter: CHAR );
VAR
  rgstr : RegPack;
BEGIN {SetDefaultDrive}
  lowerch( DriveLetter );
  IF not (DriveLetter in ['a'..'z'])
    THEN PrintMessage( InvalidDrive );
  rgstr.a.h := $E;
  rgstr.d.l := ord( DriveLetter ) - ord( 'a' );
  msdos( rgstr );
END; {SetDefaultDrive}



PROCEDURE GetDate( VAR month, day, year: INTEGER );
VAR
  rgstr : RegPack;
BEGIN {GetDate}
  WITH rgstr DO BEGIN
    a.h := $2A;  {DOS "get date" function number}
    msdos( rgstr );
    month := d.h;
    day := d.l;
    year := c.x;
  END; {WITH rgstr}
END;  {GetDate}



PROCEDURE SetDate( month, day, year: INTEGER );
VAR
  rgstr : RegPack;

  PROCEDURE quit;
  BEGIN
    abort('Invalid date.');
  END;

BEGIN {SetDate}
  WITH rgstr DO
    BEGIN
      a.h := $2B; {Set date function number}
      IF year < 1900
    THEN year := year + 1900;
      IF (year >= 1980) and (year <= 2099)
    THEN c.x := year
    ELSE quit;
      IF month in [1..12]
    THEN d.h := month
    ELSE quit;
      IF day in [1..31]
    THEN d.l := day
    ELSE quit;
      msdos( rgstr );
    END; {WITH rgstr}
END; {SetDate}



FUNCTION MkDir( DirName: dos2str80 ): ErrorMessage;
VAR
  rgstr : RegPack;
BEGIN {MkDir}
  MkDir := NoError;
  MakeAsciiZ( DirName );
  WITH rgstr DO BEGIN
    a.h := $39; {Create a sub-directory.}
    ds := seg( DirName );
    d.x := ofs( DirName );
    msdos( rgstr );
    IF FlaggedError( flags )
      THEN MkDir := MessageType( a.x );
  END; {WITH rgstr}
END; {MkDir}


FUNCTION RmDir( DirName: dos2str80 ): ErrorMessage;
VAR
  rgstr : RegPack;
BEGIN {RmDir}
  RmDir := NoError;
  MakeAsciiZ( DirName );
  WITH rgstr DO BEGIN
    a.h := $3A; {Remove a directory entry}
    ds := seg( DirName );
    d.x := ofs( DirName );
    msdos( rgstr );
    IF FlaggedError( flags )
      THEN RmDir := MessageType( a.x );
  END; {WITH rgstr}
END; {RmDir}


FUNCTION ChDir( DirName: dos2str80 ): ErrorMessage;
VAR
  rgstr : RegPack;
BEGIN {ChDir}
  ChDir := NoError;
  MakeAsciiZ( DirName );
  WITH rgstr DO BEGIN
    a.h := $3B; {Change the current directory}
    ds := seg( DirName );
    d.x := ofs( DirName );
    msdos( rgstr );
    IF FlaggedError( flags )
      THEN ChDir := MessageType( a.x );
  END; {WITH rgstr}
END; {ChDir}

FUNCTION FileExists( fname: dos2str80 ): BOOLEAN;
VAR dumset: ModeSet;
    resultofgfm: ErrorMessage;
BEGIN {FileExists}
  resultofgfm := GetFileMode( fname, dumset);
  IF resultofgfm IN [FileNotFound, PathNotFound] THEN
    FileExists := FALSE
  ELSE FileExists := TRUE;
END; {FileExists}